C**** PACKMS.F4 -- TO PACK TOGETHER MANY MS PROGRAM FILES *****
C LOAD WITH [NEW,LCS] MSSIO.FAI
	DIMENSION NAMES(635),JEXT(200),JREC(235),
	1 FIRST(128),SECOND(4000),INP(72)
C JREC(235) HAS 34 WDS FREE FOR MISC. INFO
	EQUIVALENCE(JWDS,FIRST(19)),(KREC,JREC(202)),(JEXT,NAMES(201))
	1 ,(JREC,NAMES(401))
	IREC=1
	JREC(1)=6
15	FORMAT(' P(ACK), U(NPACK), D(IRECTORY)?  '$)
18	TYPE 15
	ACCEPT 1,JWDS,K,L
	IPU=0
	MORE=0
	IF(JWDS.EQ.'P')GO TO 2
	INF=-1
	IPU=-1
	IF(JWDS.EQ.'D')	IPU=-IPU
C PACK=0,  UNPACK=-1, DIRECTORY=1
16	FORMAT(' TYPE PACK FILE NAME AND EXT.(DEFAULT EXT=.PAK)  '$)
17	TYPE 16
	ACCEPT 1,INP
	X=' '
	CALL NAMEXT(INP,IPAK,X)
	IF(INP(1).EQ.' ')IPAK=JPAK
	JPAK=IPAK
	IF(X.EQ.' ')X='PAK'
	IF(LOOKX(IPAK,X).EQ.0)GO TO 17
	IF(IPU.GT.0)GO TO 113
1	FORMAT(72A1)
2	IF(IPU.LT.0)GO TO 41
	TYPE 3
	GO TO 42
41	TYPE 40
3	FORMAT(' TYPE FIRST NAME AND EXT.(DEFAULT EXT=.MS)  '$)
40	FORMAT(' TYPE FIRST NAME AND EXT.(DEFAULT EXT=.MS) OR "ALL"  '$)
4	FORMAT(' TYPE LAST NAME OR "ALL" (NO EXT, <CR>=1 FILE ONLY)  '$)
42	ACCEPT 1,INP
	KEXT=' '
	CALL NAMEXT(INP,NAME,KEXT)
	IF(KEXT.EQ.' ')KEXT='MS'
	IF(IPU.LT.0.AND.NAME.EQ.'ALL')GO TO 122
	IF(IPU.LT.0)GO TO 19
	IF(LOOKX(NAME,KEXT).EQ.0)GO TO 2 
19	TYPE 4
	ACCEPT 1,INP
	NAME2=' '
	X2=' '
	CALL NAMEXT(INP,NAME2,X2)
	IF(NAME2.EQ.' ')NAME2=NAME
	IF(X2.EQ.' ')X2=KEXT
	IF(X2.NE.KEXT)GO TO 18
	IF(IPU.LT.0)GO TO 121
	IF(NAME2.EQ.'ALL')NAME2='99999'
12	IF(MORE.LT.0)GO TO 21
	TYPE 16
	ACCEPT 1,INP
	X=' '
	CALL NAMEXT(INP,IPAK,X)
	IF(X.EQ.' ')X='PAK'
13	IF(LOOKX(IPAK,X).EQ.0)GO TO 10
	TYPE 11
11	FORMAT(' WRITE OVER THAT NAME?  '$)
	ACCEPT 1,INP
	IF(INP(1).NE.'Y')GO TO 12
10	CALL PUTEXT(IPAK,X)
	CALL EXTOUT(NAMES,635)
C COME BACK AND FILL UP THE HEADER LATER.
21	NM=NAME
	MORE=0
20	NMX=NM
	NMZ=NM
6	IF(LOOKX(NM,KEXT).EQ.0)GO TO 1000
C JUMP IF NOT FOUND
7	CALL GETEXT(NM,KEXT)
	CALL EXTIN(FIRST,128)
	CALL EXTIN(SECOND,JWDS)
	CALL EXTOUT(FIRST,128)
	CALL EXTOUT(SECOND,JWDS)
	TYPE 9,NM,KEXT
	NAMES(IREC)=NM
	JEXT(IREC)=KEXT
	KREC=IREC
	IREC=IREC+1
	JREC(IREC)=JREC(IREC-1)+2+(JWDS-1)/128
C SAVE FOR USETI
	IF(IREC.LT.201)NAMES(IREC)=0
14	IF(NM.EQ.NAME2.OR.IREC.EQ.200)GO TO 2000
C LIMIT OF 200 FILES AT THIS TIME.
	NM=NM+2
	GO TO 6
1000	NM=NMX+256
C UPDATE 4TH CHAR.  (E.G. AAAAA TO AAABA)
	NMX=NM
	IF(LOOKX(NM,KEXT).LT.0)GO TO 7
	NM=NMZ+32768
C UPDATE 3RD CHAR. (E.G. AAAAA TO AABAA)
	NMX=NM
	NMZ=NM
	IF(LOOKX(NM,KEXT).LT.0)GO TO 7
C NOW ALL DONE.  REBUILD HEADER.
2001	FORMAT(' ADD MORE TO FILE?  '$)
2000	TYPE 2001
	ACCEPT 1,K
	MORE=-1
	IF(K.EQ.'Y')GO TO 2
	CALL USTO(1)
	CALL EXTOUT(NAMES,635)
	CALL FINEXT
	TYPE 8,IPAK,X,KREC
	CALL EXIT
8	FORMAT(' ***** ALL DONE WRITING ',A5,'.',A3/5XI3,' FILES')
9	FORMAT(1XA5,'.',A3)
122	IPU=4
121	TYPE 111
111	FORMAT(' CHANGE EXTENSION TO -- (<CR>=NO CHANGE)  '$)
112	FORMAT(A3)
	ACCEPT 112,NEXT
	IF(NEXT.NE.' ')KEXT=NEXT
113	CALL GETEXT(IPAK,X)
	CALL EXTIN(NAMES,635)
	IF(IPU.LE.0)GO TO 114
	GO TO(109,2,118,3000)IPU
118	GO TO 18
115	FORMAT(' TYPE NEW NAME AND EXT.  '$)
119	MEXT=' '
	TYPE 115
	ACCEPT 1,INP
	CALL NAMEXT(INP,NAME2,MEXT)
	IF(MEXT.EQ.' ')MEXT=KEXT
	NMX=0
	DO 116 K=1,200
	NN=NAMES(K)
	MM=JEXT(K)
	IF(NAME.EQ.NN.AND.KEXT.EQ.MM)NMX=K
116	IF(NAME2.EQ.NN.AND.MEXT.EQ.MM)GO TO 117
	IF(NMX.NE.0)GO TO 120
	TYPE 102
	CALL EXIT
120	NAMES(NMX)=NAME2
	JEXT(NMX)=MEXT
	CALL EXIT
CCCC GO WRITE NEW FORM OF .PAK FILE	GO TO ????
117	TYPE 11
	ACCEPT 1,JWDS
	IF(JWDS.NE.'Y')GO TO 18
114	NM=NAME
	NN=NM
105	DO 101 K=1,200
101	IF(NAMES(K).EQ.NAME)GO TO 108
	NAME=NM+256
	NM=NAME
	DO 107 K=1,200
107	IF(NAMES(K).EQ.NAME)GO TO 108
	NAME=NN+32768
	NN=NAME
	NM=NN
	DO 177 K=1,200
177	IF(NAMES(K).EQ.NAME)GO TO 108
106	IF(INF.NE.0)TYPE 102
	GO TO 18
102	FORMAT(' FILE NOT FOUND')
108	CALL USTI(JREC(K))
	CALL EXTIN(FIRST,128)
	CALL EXTIN(SECOND,JWDS)
	TYPE 9,NAME,KEXT
	INF=0
104	IF(LOOKX(NAME,KEXT).EQ.0)GO TO 103
C IS FILE ALREADY ON DSK?
	TYPE 11
	ACCEPT 1,K
	IF(K.EQ.'Y')GO TO 103
	TYPE 3   
	ACCEPT 1,INP
	CALL NAMEXT(INP,NAME,KEXT)
	GO TO 104
103	CALL PUTEXT(NAME,KEXT)
	CALL EXTOUT(FIRST,128)
	CALL EXTOUT(SECOND,JWDS)
	CALL FINEXT
	IF(NAME.EQ.NAME2)CALL EXIT
	NAME=NAME+2
	GO TO 105
3004	FORMAT(3XI3,' FILES'/)
109	TYPE 3004,KREC
	 DO 110 K=1,200
	IF(NAMES(K).EQ.0)GO TO 18
110	TYPE 9,NAMES(K),JEXT(K)
	GO TO 18
3000	DO 3001 K=1,200
	NM=NAMES(K)
	IF(NM.EQ.0)CALL EXIT
	MM=JEXT(K)
	IF(NEXT.NE.' ')MM=NEXT
	CALL EXTIN(FIRST,128)
	CALL EXTIN(SECOND,JWDS)
	TYPE 9,NM,MM
3003	IF(LOOKX(NM,MM).EQ.0)GO TO 3002
	TYPE 11
	ACCEPT 1,L
	IF(L.NE.'Y')GO TO 3001
3002	CALL PUTEXT(NM,MM)
	CALL EXTOUT(FIRST,128)
	CALL EXTOUT(SECOND,JWDS)
	CALL FINEXT
3001	CONTINUE
	END

	SUBROUTINE NAMEXT(I,NAME,IEXT)
C FINDS NAME.EXT IN A1 STRING
	DIMENSION I(1)

	IF(I(1).NE.-1)GO TO 9
C FIRST PASS UP 'G', 'GM', 'RS', ETC.  (=-1)
	DO 1 K=1,72
1	IF(I(K).EQ.' ')GO TO 2
C NOW PASS BLANKS
2	J=72
	DO 3 J=K+1,72
3	IF(I(J).NE.' ')GO TO 4
C NOW FOUND START OF WORD (UNLESS ALL BLANKS)
4	IF(J.NE.72)GO TO 5
	NAME=' '
	RETURN
9	J=1
5	DO 6 K=J,72
	IF(I(K).EQ.' ')GO TO 7
C JUMP IF NAME ONLY
6	IF(I(K).EQ.'.')GO TO 8
7	CALL PACKX(NAME,I(J))
	RETURN
8	CALL RLOOP(I(61),I(J),K-J)
	CALL PACKX(NAME,I(61))
	CALL PACKX(IEXT,I(K+1))
	END

	SUBROUTINE PACKX(NAM,KNM)
	DIMENSION KNM(5)
	DATA KK/128/,LL/"377777777777/,JJ/"2000000000/
	1 , MM/"774000000000/
	NAM=0
	DO 12 K=5,1,-1
	NAM=NAM .OR. (KNM(K) .AND. MM)
	IF (K.EQ.1)RETURN
17	IF (NAM.GE.0)GO TO 13
	NAM = (( NAM .AND. LL)/KK) .OR. JJ
	GO TO 12
13	NAM = NAM / KK
12	CONTINUE
	RETURN
	END